home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / io.c < prev    next >
C/C++ Source or Header  |  1992-10-21  |  9KB  |  358 lines
  1. /* Ports
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. #include <errno.h>
  7. #include <pwd.h>
  8. #include <sys/types.h>
  9. #include <sys/param.h>
  10. #include <sys/stat.h>
  11.  
  12. #ifdef SYSCONF
  13. #  include <unistd.h>
  14. #endif
  15.  
  16. extern int errno;
  17. extern char *getenv();
  18.  
  19. Object Curr_Input_Port, Curr_Output_Port;
  20. Object Standard_Input_Port, Standard_Output_Port;
  21.  
  22. Object Make_Port();
  23.  
  24. Init_Io () {
  25.     Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
  26.     Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
  27.     Curr_Input_Port = Standard_Input_Port;
  28.     Curr_Output_Port = Standard_Output_Port;
  29.     Global_GC_Link (Standard_Input_Port);
  30.     Global_GC_Link (Standard_Output_Port);
  31.     Global_GC_Link (Curr_Input_Port);
  32.     Global_GC_Link (Curr_Output_Port);
  33. }
  34.  
  35. Reset_IO (destructive) {
  36.     Discard_Input (Curr_Input_Port);
  37.     if (destructive)
  38.     Discard_Output (Curr_Output_Port);
  39.     else
  40.     Flush_Output (Curr_Output_Port);
  41.     Curr_Input_Port = Standard_Input_Port;
  42.     Curr_Output_Port = Standard_Output_Port;
  43. }
  44.  
  45. Object Make_Port (flags, f, name) FILE *f; Object name; {
  46.     Object port;
  47.     GC_Node;
  48.  
  49.     GC_Link (name);
  50.     port = Alloc_Object (sizeof (struct S_Port), T_Port, 0);
  51.     PORT(port)->flags = flags|P_OPEN;
  52.     PORT(port)->file = f;
  53.     PORT(port)->name = name;
  54.     PORT(port)->ptr = 0;
  55.     PORT(port)->lno = 1;
  56.     GC_Unlink;
  57.     return port;
  58. }
  59.  
  60. Object P_Port_File_Name (p) Object p; {
  61.     Check_Type (p, T_Port);
  62.     return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
  63. }
  64.  
  65. Object P_Port_Line_Number (p) Object p; {
  66.     Check_Type (p, T_Port);
  67.     return Make_Unsigned (PORT(p)->lno);
  68. }
  69.  
  70. Object P_Eof_Objectp (x) Object x; {
  71.     return TYPE(x) == T_End_Of_File ? True : False;
  72. }
  73.  
  74. Object P_Curr_Input_Port () { return Curr_Input_Port; }
  75.  
  76. Object P_Curr_Output_Port () { return Curr_Output_Port; }
  77.  
  78. Object P_Input_Portp (x) Object x; {
  79.     return TYPE(x) == T_Port && IS_INPUT(x) ? True : False;
  80. }
  81.  
  82. Object P_Output_Portp (x) Object x; {
  83.     return TYPE(x) == T_Port && IS_OUTPUT(x) ? True : False;
  84. }
  85.  
  86. int Path_Max () {
  87. #ifdef PATH_MAX          /* POSIX */
  88.     return PATH_MAX;
  89. #else
  90. #ifdef MAXPATHLEN        /* 4.3 BSD */
  91.     return MAXPATHLEN;
  92. #else
  93. #ifdef SYSCONF
  94.     static r; 
  95.     if (r == 0) {
  96.     if ((r = pathconf ("/", _PC_PATH_MAX)) == -1)
  97.         r = 1024;
  98.     r++;
  99.     }
  100.     return r;
  101. #else
  102.     return 1024;
  103. #endif
  104. #endif
  105. #endif
  106. }
  107.  
  108. Object Get_File_Name (name) Object name; {
  109.     register len;
  110.  
  111.     if (TYPE(name) == T_Symbol)
  112.     name = SYMBOL(name)->name;
  113.     else if (TYPE(name) != T_String)
  114.     Wrong_Type_Combination (name, "string or symbol");
  115.     if ((len = STRING(name)->size) > Path_Max () || len == 0)
  116.     Primitive_Error ("invalid file name");
  117.     return name;
  118. }
  119.  
  120. char *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
  121.     register char *p; 
  122.     struct passwd *pw, *getpwnam();
  123.  
  124.     if (*s++ != '~')
  125.     return 0;
  126.     for (p = s; *p && *p != '/'; p++)
  127.     ;
  128.     if (*p == '/') *p++ = 0;
  129.     if (*s == '\0') {
  130.     if ((*dirp = getenv ("HOME")) == 0)
  131.         *dirp = "";
  132.     } else {
  133.     if ((pw = getpwnam (s)) == 0)
  134.         Primitive_Error ("unknown user: ~a", Make_String (s, strlen (s)));
  135.     *dirp = pw->pw_dir;
  136.     } 
  137.     return p;
  138. }
  139.  
  140. Object General_File_Operation (s, op) Object s; register op; {
  141.     register char *r;
  142.     Object ret, fn;
  143.     Alloca_Begin;
  144.  
  145.     fn = Get_File_Name (s);
  146.     Make_C_String (fn, r);
  147.     switch (op) {
  148.     case 0: {
  149.     char *p, *dir;
  150.     if ((p = Internal_Tilde_Expand (r, &dir)) == 0) {
  151.         Alloca_End;
  152.         return s;
  153.     }
  154.     Alloca (r, char*, strlen (dir) + 1 + strlen (p));
  155.     sprintf (r, "%s/%s", dir, p);
  156.     ret = Make_String (r, strlen (r));
  157.     Alloca_End;
  158.     return ret;
  159.     }
  160.     case 1: {
  161.     struct stat st;
  162.     /* Doesn't make much sense to check for errno != ENOENT here:
  163.      */
  164.     ret = stat (r, &st) == 0 ? True : False;
  165.     Alloca_End;
  166.     return ret;
  167.     }}
  168.     /*NOTREACHED*/
  169. }
  170.  
  171. Object P_Tilde_Expand (s) Object s; {
  172.     return General_File_Operation (s, 0);
  173. }
  174.  
  175. Object P_File_Existsp (s) Object s; {
  176.     return General_File_Operation (s, 1);
  177. }
  178.  
  179. Close_All_Files () {
  180.     Terminate_All (T_Port);
  181. }
  182.  
  183. void Terminate_File (port) Object port; {
  184.     (void)fclose (PORT(port)->file);
  185.     PORT(port)->flags &= ~P_OPEN;
  186. }
  187.  
  188. Object Open_File (name, flags, err) char *name; {
  189.     register FILE *f;
  190.     char *dir, *p;
  191.     Object fn, port;
  192.     struct stat st;
  193.     Alloca_Begin;
  194.  
  195.     if (p = Internal_Tilde_Expand (name, &dir)) {
  196.     Alloca (name, char*, strlen (dir) + 1 + strlen (p));
  197.     sprintf (name, "%s/%s", dir, p);
  198.     }
  199.     if (!err && stat (name, &st) == -1 &&
  200.         (errno == ENOENT || errno == ENOTDIR)) {
  201.     Alloca_End;
  202.     return Null;
  203.     }
  204.     switch (flags & (P_INPUT|P_BIDIR)) {
  205.     case 0:               p = "w";  break;
  206.     case P_INPUT:         p = "r";  break;
  207.     default:              p = "r+"; break;
  208.     }
  209.     fn = Make_String (name, strlen (name));
  210.     if ((f = fopen (name, p)) == NULL) {
  211.     Saved_Errno = errno;  /* errno valid here? */
  212.     Primitive_Error ("~s: ~E", fn);
  213.     }
  214.     port = Make_Port (flags, f, fn);
  215.     Register_Terminate (port, Terminate_File);
  216.     Alloca_End;
  217.     return port;
  218. }
  219.  
  220. Object General_Open_File (name, flags, path) Object name, path; {
  221.     Object port, pref;
  222.     char *buf = 0;
  223.     register char *fn;
  224.     register plen, len, blen = 0, gotpath = 0;
  225.     Alloca_Begin;
  226.  
  227.     name = Get_File_Name (name);
  228.     len = STRING(name)->size;
  229.     fn = STRING(name)->data;
  230.     if (fn[0] != '/' && fn[0] != '~') {
  231.     for ( ; TYPE(path) == T_Pair; path = Cdr (path)) {
  232.         pref = Car (path);
  233.         if (TYPE(pref) == T_Symbol)
  234.         pref = SYMBOL(pref)->name;
  235.         if (TYPE(pref) != T_String)
  236.         continue;
  237.         gotpath = 1;
  238.         if ((plen = STRING(pref)->size) > Path_Max () || plen == 0)
  239.         continue;
  240.         if (len + plen + 2 > blen) {
  241.         blen = len + plen + 2;
  242.         Alloca (buf, char*, blen);
  243.         }
  244.         bcopy (STRING(pref)->data, buf, plen);
  245.         if (buf[plen-1] != '/')
  246.         buf[plen++] = '/';
  247.         bcopy (fn, buf+plen, len);
  248.         buf[len+plen] = '\0';
  249.         port = Open_File (buf, flags, 0);
  250.         /* No GC has been taken place in Open_File() if it returns Null.
  251.          */
  252.         if (!Nullp (port)) {
  253.         Alloca_End;
  254.         return port;
  255.         }
  256.     }
  257.     }
  258.     if (gotpath)
  259.     Primitive_Error ("file ~s not found", name);
  260.     if (len + 1 > blen)
  261.     Alloca (buf, char*, len + 1);
  262.     bcopy (fn, buf, len);
  263.     buf[len] = '\0';
  264.     port = Open_File (buf, flags, 1);
  265.     Alloca_End;
  266.     return port;
  267. }
  268.  
  269. Object P_Open_Input_File (name) Object name; {
  270.     return General_Open_File (name, P_INPUT, Null);
  271. }
  272.  
  273. Object P_Open_Output_File (name) Object name; {
  274.     return General_Open_File (name, 0, Null);
  275. }
  276.  
  277. Object P_Open_Input_Output_File (name) Object name; {
  278.     return General_Open_File (name, P_BIDIR, Null);
  279. }
  280.  
  281. Object General_Close_Port (port) Object port; {
  282.     register flags;
  283.     FILE *f;
  284.  
  285.     Check_Type (port, T_Port);
  286.     flags = PORT(port)->flags;
  287.     if (!(flags & P_OPEN) || (flags & P_STRING))
  288.     return Void;
  289.     f = PORT(port)->file;
  290.     if (f == stdin || f == stdout)
  291.     return Void;
  292.     if (fclose (f) == EOF) {
  293.     Saved_Errno = errno;   /* errno valid here? */
  294.     Primitive_Error ("write error on ~s: ~E", port);
  295.     }
  296.     PORT(port)->flags &= ~P_OPEN;
  297.     Deregister_Terminate (port);
  298.     return Void;
  299. }
  300.  
  301. Object P_Close_Input_Port (port) Object port; {
  302.     return General_Close_Port (port);
  303. }
  304.  
  305. Object P_Close_Output_Port (port) Object port;{
  306.     return General_Close_Port (port);
  307. }
  308.  
  309. #define General_With(prim,curr,flags) Object prim (name, thunk)\
  310.     Object name, thunk; {\
  311.     Object old, ret;\
  312.     GC_Node2;\
  313. \
  314.     Check_Procedure (thunk);\
  315.     old = curr;\
  316.     GC_Link2 (thunk, old);\
  317.     curr = General_Open_File (name, flags, Null);\
  318.     ret = Funcall (thunk, Null, 0);\
  319.     (void)General_Close_Port (curr);\
  320.     GC_Unlink;\
  321.     curr = old;\
  322.     return ret;\
  323. }
  324.  
  325. General_With (P_With_Input, Curr_Input_Port, P_INPUT)
  326. General_With (P_With_Output, Curr_Output_Port, 0)
  327.  
  328. Object General_Call_With (name, flags, proc) Object name, proc; {
  329.     Object port, ret;
  330.     GC_Node2;
  331.  
  332.     Check_Procedure (proc);
  333.     GC_Link2 (proc, port);
  334.     port = General_Open_File (name, flags, Null);
  335.     port = Cons (port, Null);
  336.     ret = Funcall (proc, port, 0);
  337.     (void)General_Close_Port (Car (port));
  338.     GC_Unlink;
  339.     return ret;
  340. }
  341.  
  342. Object P_Call_With_Input (name, proc) Object name, proc; {
  343.     return General_Call_With (name, P_INPUT, proc);
  344. }
  345.  
  346. Object P_Call_With_Output (name, proc) Object name, proc; {
  347.     return General_Call_With (name, 0, proc);
  348. }
  349.  
  350. Object P_Open_Input_String (string) Object string; {
  351.     Check_Type (string, T_String);
  352.     return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
  353. }
  354.  
  355. Object P_Open_Output_String () {
  356.     return Make_Port (P_STRING, (FILE *)0, Make_String ((char *)0, 0));
  357. }
  358.